home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok71.lha / Formula / Formula.mod < prev    next >
Text File  |  1993-08-15  |  25KB  |  888 lines
  1.  
  2. (*********************************************************************
  3.  
  4.     :Program.    Formula
  5.     :Contents.   Module to evaluate numeric expressions like
  6.     :Contents.   "sin(x)/epsilon*(time-7.2E3)"
  7.     :Author.     Stefan Salewski
  8.     :Address.    Stefan Salewski, Stolper Weg 3, D-2160 Stade
  9.     :Copyright.  © 1992 by Stefan Salewski, see file Formula.doc
  10.     :Language.   Oberon
  11.     :Translator. Amiga-Oberon-Compiler V2.14d
  12.     :Remark.     Compile it with options 882 and 68030 set if You use
  13.     :Remark.     it on an A3000. This speed up the calculations
  14.     :Remark.     Be careful if You turn off stackcheck, this module
  15.     :Remark.     uses recursion!
  16.     :Remark.     No line in this file is longer than 70 characters!
  17.     :Remark.     There is some death code in a few CASE-statments.
  18.     :Remark.     I think this will not slow down the operations,
  19.     :Remark.     but makes it more secure. Safety First!
  20.     :History.    V1.0    11 MAY 1992
  21.  
  22. *********************************************************************)
  23.  
  24. MODULE Formula;
  25.   IMPORT
  26.     ASCII,
  27.     AVL,
  28.     Break, (* we don't really need it *)
  29.     LRC2:LongRealConversions2, (* from AMOK#58 *)
  30.     MATHLIB,
  31.     MathIEEEDoubBas, (* Floor() and Ceil() *)
  32.     (*MathIEEEDoubTrans, (* Pow() *) *)
  33.     NoGuru,
  34.     OberonLib, (* only StackCheck() *)
  35.     Random,
  36.     Requests,
  37.     Strings,
  38.     TF:TurboFiles; (* from AMOK#56, TurboFiles V1.1 is on this disk *)
  39.  
  40.   CONST (* public Consts *)
  41.     Functions=31;  (* How much math. functions like "sin"  I know *)
  42.     FuncStrSize=8; (* >=LEN('DegToRad') *)
  43.     Values=2048;   (* how much values like Pi, VelocityOfLight ...  *)
  44.     Consts=512;    (*how much const. numbers like '1.2E7' in formula*)
  45.     FormulaSize=1024; (* Formula can contain 1024 elements. element *)
  46.                       (* means a number, an operator like "+",      *)
  47.                       (* a bracket or a basic function like sin()   *)
  48.  
  49.   TYPE
  50.     WriteProc*=PROCEDURE(str:ARRAY OF CHAR);
  51.     Formula*=RECORD
  52.                el:ARRAY FormulaSize OF INTEGER;
  53.                const:ARRAY Consts OF LONGREAL;
  54.                error*:INTEGER;
  55.              END;
  56.  
  57.   CONST (* Errornumbers, = formula.error *)
  58.     NoError*        = 0;
  59.     (* Errors from Evaluate() *)
  60.     Overflow*       = 1;
  61.     DivisionByZero* = 2;
  62.     sqrtError*      = 3;
  63.     lnError*        = 4;
  64.     arcsinError*    = 5;
  65.     arccosError*    = 6;
  66.     artanhError*    = 7;
  67.     facError*       = 8;
  68.     rndError*       = 9;
  69.     entierError*    = 10;
  70.     powError*       = 11;
  71.     (* Errors from Compile() *)
  72.     CompileError*   = 12;
  73.  
  74.   TYPE
  75.     String80=ARRAY 80 OF CHAR;
  76.     EText=ARRAY 13 OF String80;
  77.  
  78.   CONST  (* Messages for the Errornumbers above *)
  79.     ErrorText*=EText('No Error',
  80.                      'Overflow: ABS(Result) >= MAX(LONGREAL)',
  81.                      'Division by Zero',
  82.                      'sqrt(x) only for x>=0',
  83.                      'ln(x) only for x>0',
  84.                      'arcsin(x) only for ABS(x)<=1',
  85.                      'arccos(x) only for ABS(x)<=1',
  86.                      'artanh(x) only for -1 < x < +1 ',
  87.                      'fac(x) only for x = {0,1,2,...,170}',
  88.                      'rnd(x) only for x = {1,2,3,...,MAX(INTEGER)}',
  89.                      'entier(x) only for ABS(x)<MAX(LONGINT)',
  90.                      'x^y: if x is negative, y must be an integer',
  91.                      'Error in Compile()'
  92.                     );
  93.  
  94.   CONST (* private *)
  95.     MinStack=FormulaSize*10; (* recursion needs a large stack *)
  96.     (* I think stacksize is proportional to FormulaSize *)
  97.     FirstValue=0; (* Never change this *)
  98.     LastValue=Values-1;
  99.     FirstConst=LastValue+1;
  100.     LastConst=FirstConst+Consts-1;
  101.     FirstFunction=LastConst+1;
  102.     LastFunction=FirstFunction+Functions-1;
  103.  
  104.     FirstOp=LastFunction+1;
  105.     Bra=FirstOp+0;
  106.     Ket=FirstOp+1;
  107.     Plus=FirstOp+2;
  108.     Minus=FirstOp+3;
  109.     Times=FirstOp+4;
  110.     Div=FirstOp+5;
  111.     Hi=FirstOp+6;
  112.     EOF=FirstOp+7;
  113.     LastOp=EOF;
  114.  
  115.   TYPE
  116.     FuncStr=ARRAY FuncStrSize OF CHAR; (* 'sin', 'arctan', ... *)
  117.     FuncNames= ARRAY Functions OF FuncStr;
  118.  
  119.   CONST
  120.     FunctionArray=
  121.       FuncNames('id','jump','entier','int','abs','sqr','sqrt',
  122.                 'exp','ln','log','log10','log2','tentox','twotox',
  123.                 'sin','arcsin','cos','arccos','tan','arctan',
  124.                 'sinh','cosh','tanh','artanh',
  125.                 'DegToRad','RadToDeg','RND','fac',
  126.                 'ceil','floor','round');
  127.  
  128.     F=FirstFunction;
  129.     id=F+0; jump=F+1; entier=F+2; int=F+3; abs=F+4; sqr=F+5; sqrt=F+6;
  130.     exp=F+7; ln=F+8; log=F+9; log10=F+10; log2=F+11; tentox=F+12;
  131.     twotox=F+13; sin=F+14; arcsin=F+15; cos=F+16; arccos=F+17;
  132.     tan=F+18; arctan=F+19; sinh=F+20; cosh=F+21; tanh=F+22;
  133.     artanh=F+23; DegToRad=F+24; RadToDeg=F+25; RND=F+26; fac=F+27;
  134.     ceil=F+28; floor=F+29; round=F+30;
  135.  
  136.     AVLStringSize=SIZE(AVL.String);
  137.     Pi=3.141592653589793D;
  138.     MaxFac=170; (* fac(MaxFac+1) > MAX(LONGREAL) *)
  139.     Space=' ';
  140.     OoM="Not enougth Memory!";
  141.     ImpossibleError="I thought this is an impossible error!";
  142.  
  143.   TYPE
  144.     Comment=String80;
  145.     ValueNodePtr=POINTER TO ValueNode;
  146.     ValueNode=RECORD (AVL.SNode)
  147.       index:INTEGER;
  148.       trash:BOOLEAN; (* IF trash, we don't save this value to disk *)
  149.       comment:Comment;
  150.     END;
  151.  
  152.     FuncNodePtr=POINTER TO FuncNode;
  153.     FuncNode=RECORD (AVL.SNode)
  154.       index:INTEGER;
  155.     END;
  156.  
  157.     ValueArray=ARRAY Values OF LONGREAL;
  158.  
  159.   VAR
  160.     root:AVL.SRoot;
  161.     file:TF.File;
  162.     writeProc:WriteProc;
  163.     Fac:ARRAY (MaxFac+1) OF LONGREAL;
  164.     values:POINTER TO ValueArray;(* Allocate this array dynamically,*)
  165.                                 (*so we can use the small data model*)
  166.     ValueCounter:INTEGER;
  167.  
  168.  
  169.   PROCEDURE ImpErr;
  170.   BEGIN Requests.Assert(FALSE,ImpossibleError)
  171.   END ImpErr;
  172.  
  173.   PROCEDURE InitFac;
  174.     VAR
  175.       i:INTEGER;
  176.   BEGIN
  177.     i:=1;
  178.     Fac[0]:=1;
  179.     REPEAT
  180.       Fac[i]:=i*Fac[i-1];
  181.       INC(i);
  182.     UNTIL i>MaxFac;
  183.   END InitFac;
  184.  
  185.   PROCEDURE FAC(VAR x:LONGREAL):BOOLEAN;
  186.     VAR l:LONGINT;
  187.   BEGIN
  188.     IF (x<0) OR (x>MaxFac) THEN RETURN FALSE END;
  189.     l:=ENTIER(x);
  190.     IF x#l THEN
  191.       RETURN FALSE
  192.     ELSE
  193.       x:=Fac[l];
  194.       RETURN TRUE
  195.     END;
  196.   END FAC;
  197.  
  198.   PROCEDURE RN(VAR x:LONGREAL):BOOLEAN;
  199.     VAR i:INTEGER;
  200.   BEGIN
  201.     IF (x<1) OR (x>=MAX(INTEGER)) THEN RETURN FALSE END;
  202.     i:=SHORT(ENTIER(x));
  203.     IF x#i THEN
  204.       RETURN FALSE
  205.     ELSE
  206.       x:=Random.RND(i);
  207.       RETURN TRUE;
  208.     END;
  209.   END RN;
  210.  
  211.   PROCEDURE FindValue*(name:ARRAY OF CHAR; VAR x:LONGREAL;
  212.                        VAR comment:ARRAY OF CHAR):BOOLEAN;
  213.   (* $CopyArrays- *)
  214.     VAR
  215.       snodePtr:AVL.SNodePtr;
  216.       str:AVL.String;
  217.   BEGIN
  218.     x:=0;
  219.     comment:='';
  220.     COPY(name,str);
  221.     snodePtr:=AVL.SFind(root,str);
  222.     IF snodePtr=NIL THEN RETURN FALSE END;
  223.     IF snodePtr IS FuncNode THEN RETURN FALSE END;
  224.     IF snodePtr IS ValueNode THEN
  225.       COPY(snodePtr(ValueNode).comment,comment);
  226.       x:=values^[snodePtr(ValueNode).index];
  227.       RETURN TRUE;
  228.     ELSE
  229.       ImpErr
  230.     END;
  231.   END FindValue;
  232.  
  233.   PROCEDURE GetIndex*(name:ARRAY OF CHAR;VAR index:INTEGER):BOOLEAN;
  234.   (* $CopyArrays- *)
  235.     VAR
  236.       snodePtr:AVL.SNodePtr;
  237.       str:AVL.String;
  238.   BEGIN
  239.     index:=-1;
  240.     COPY(name,str);
  241.     snodePtr:=AVL.SFind(root,str);
  242.     IF snodePtr=NIL THEN RETURN FALSE END;
  243.     IF snodePtr IS FuncNode THEN RETURN FALSE END;
  244.     IF snodePtr IS ValueNode THEN
  245.       index:=snodePtr(ValueNode).index;
  246.       RETURN TRUE;
  247.     ELSE
  248.       ImpErr
  249.     END;
  250.   END GetIndex;
  251.  
  252.   PROCEDURE ChangeValue*(index:INTEGER; value:LONGREAL);
  253.   BEGIN
  254.     (* only for 0 <= index < MaxValues *)
  255.     values^[index]:=value
  256.   END ChangeValue;
  257.  
  258.   PROCEDURE Split*(VAR str1,str2:ARRAY OF CHAR; c:CHAR):BOOLEAN;
  259.   (* splits str1 at position determined by c in str1 and str2      *)
  260.   (* If str1="" then str1:="" and str2:=""                         *)
  261.   (* IF c is the last  Char in str1 then str1:=str1-c and str2:="" *)
  262.   (* IF c is the first Char in str1 then str1:="" and str2:=str1-c *)
  263.   (* RETURNS TRUE if (c is in str1)                                *)
  264.     VAR
  265.       i:INTEGER;
  266.       j,l:INTEGER;
  267.       found:BOOLEAN;
  268.   BEGIN
  269.     i:=0; j:=0; found:=FALSE;
  270.     l:=Strings.Length(str1);
  271.     WHILE (i<l) AND (str1[i]#c) DO INC(i) END;
  272.     IF i<l THEN str1[i]:=0X; found:=TRUE END;
  273.     INC(i);
  274.     WHILE (i<l) AND (j<LEN(str2)) DO
  275.       str2[j]:=str1[i];
  276.       INC(i); INC(j);
  277.     END;
  278.     IF j<LEN(str2) THEN str2[j]:=0X END;
  279.     RETURN found
  280.   END Split;
  281.  
  282.   PROCEDURE DeleteSpaces*(VAR str:ARRAY OF CHAR);
  283.   (* removes all spaces on the left and right side of str *)
  284.     VAR
  285.       i:INTEGER;
  286.   BEGIN
  287.     i:=0;
  288.     WHILE (i<LEN(str)) AND (str[i]=Space) DO INC(i) END;
  289.     IF i>0 THEN Strings.Delete(str,0,i) END;
  290.     i:=Strings.Length(str);
  291.     WHILE (i>0) AND (str[i-1]=Space) DO DEC(i); str[i]:=0X END;
  292.   END DeleteSpaces;
  293.  
  294.   PROCEDURE Divide*(VAR input,name,expression,comment:ARRAY OF CHAR);
  295.   (*   input=      "pi =  2*arcsin(1) ; ~3.14"
  296.    ==> name=       "pi"
  297.    ==> expression= "2*arcsin(1)"
  298.    ==> comment=    "~3.14"
  299.   *)
  300.   BEGIN
  301.     IF Split(input,comment,';') THEN DeleteSpaces(comment) END;
  302.     IF Split(input,expression,'=') THEN
  303.       DeleteSpaces(expression);
  304.       DeleteSpaces(input);
  305.       COPY(input,name)
  306.     ELSE
  307.       name:='';
  308.       DeleteSpaces(input);
  309.       COPY(input,expression);
  310.     END;
  311.   END Divide;
  312.  
  313.   PROCEDURE NameOK(name:ARRAY OF CHAR):BOOLEAN;
  314.   (* $CopyArrays- *)
  315.     VAR
  316.       i:INTEGER;
  317.   BEGIN
  318.     (*IF Strings.Length(name)>AVLStringSize THEN RETURN FALSE END;*)
  319.     IF (name[0]>='0') AND (name[0]<='9') THEN RETURN FALSE END;
  320.     i:=0;
  321.     LOOP
  322.       IF i=LEN(name) THEN EXIT END;
  323.       CASE name[i] OF
  324.         0X:EXIT|
  325.         01X..ASCII.us,ASCII.del,ASCII.csi,Space,'+','-','*','/','^',
  326.         '(','[','{','}',']',')',':','=','.':
  327.         RETURN FALSE
  328.       ELSE END;
  329.       INC(i);
  330.     END;
  331.     RETURN (i>0) AND (i<AVLStringSize)
  332.   END NameOK;
  333.  
  334.   PROCEDURE DefineValue*(name:ARRAY OF CHAR;value:LONGREAL;
  335.                          trash:BOOLEAN;comment:ARRAY OF CHAR):BOOLEAN;
  336.   (* $CopyArrays- *)
  337.     VAR
  338.       vPtr:ValueNodePtr;
  339.       el:AVL.SNodePtr;
  340.       avlName:AVL.String;
  341.   BEGIN
  342.     IF NOT NameOK(name) THEN RETURN FALSE END;
  343.     COPY(name,avlName);
  344.     el:=AVL.SFind(root,avlName);
  345.     IF (el#NIL) THEN
  346.       IF (el IS ValueNode) THEN
  347.         COPY (comment,el(ValueNode).comment);
  348.         el(ValueNode).trash:=trash;
  349.         values^[el(ValueNode).index]:=value;
  350.         RETURN TRUE
  351.       ELSE
  352.         RETURN FALSE
  353.       END;
  354.     END;
  355.     IF ValueCounter=Values THEN RETURN FALSE END;
  356.     NEW(vPtr);
  357.     Requests.Assert(vPtr#NIL,OoM);
  358.     vPtr.name:=avlName;
  359.     COPY(comment,vPtr.comment);
  360.     vPtr.index:=ValueCounter;
  361.     vPtr.trash:=trash;
  362.     IF AVL.SAdd(root,vPtr) THEN
  363.       values^[ValueCounter]:=value;
  364.       INC(ValueCounter);
  365.       RETURN TRUE
  366.     ELSE
  367.       RETURN FALSE
  368.     END;
  369.   END DefineValue;
  370.  
  371.   PROCEDURE LoadValues*(filename:ARRAY OF CHAR):BOOLEAN;
  372.   (* $CopyArrays- *)
  373.     CONST
  374.       LineLen=256;
  375.     VAR
  376.       ok:BOOLEAN;
  377.       file:TF.File;
  378.       line:ARRAY LineLen OF CHAR;
  379.       name:AVL.String;
  380.       value:String80;
  381.       com:Comment;
  382.       x:LONGREAL;
  383.       len:INTEGER;
  384.   BEGIN
  385.     (* Don't delete old values, only add new or overwrite old values *)
  386.     IF TF.Open(file,filename,1024,TF.oldFile) THEN
  387.       LOOP
  388.         len:=TF.ReadString(file,line);
  389.         ok:=len<LineLen;
  390.         IF NOT ok THEN EXIT END;
  391.         IF len>0 THEN
  392.           Divide(line,name,value,com);
  393.           IF (name#'') OR (value#'') THEN
  394.             ok:=NameOK(name) & (value#'') & LRC2.StringToReal(value,x)
  395.                 AND DefineValue(name,x,FALSE,com);
  396.             IF NOT ok THEN EXIT END;
  397.           END;
  398.         END;
  399.         IF (file.res#TF.done) THEN EXIT END;
  400.       END;
  401.       ok:=ok AND (file.res=TF.endOfFile);
  402.       RETURN TF.Close(file) AND ok;
  403.     ELSE
  404.       RETURN FALSE
  405.     END;
  406.   END LoadValues;
  407.  
  408.   PROCEDURE * SaveValue(el:AVL.NodePtr);
  409.     CONST GS=14;
  410.     VAR
  411.       i:INTEGER;
  412.       str:ARRAY (GS+7) OF CHAR;
  413.   BEGIN
  414.     IF (el IS ValueNode) AND NOT el(ValueNode).trash THEN
  415.       WITH el:ValueNode DO
  416.         IF TF.WriteString(file,el.name) THEN END;
  417.         i:=Strings.Length(el.name);
  418.         WHILE i<20 DO
  419.           IF TF.WriteChar(file,Space) THEN END;
  420.           INC(i)
  421.         END;
  422.         IF TF.WriteString(file,' = ') THEN END;
  423.        IF NOT LRC2.RealToString(values^[el.index],str,GS,GS,TRUE,TRUE)
  424.         THEN ImpErr END;
  425.         IF TF.WriteString(file,str) THEN END;
  426.         IF el.comment#'' THEN
  427.           IF TF.WriteString(file,' ; ') THEN END;
  428.           IF TF.WriteString(file,el.comment) THEN END;
  429.         END;
  430.       END;
  431.       IF TF.WriteLn(file) THEN END;
  432.     END;
  433.   END SaveValue;
  434.  
  435.   PROCEDURE SaveValues*(filename:ARRAY OF CHAR):BOOLEAN;
  436.   (* $CopyArrays- *)
  437.     VAR
  438.       ok:BOOLEAN;
  439.   BEGIN
  440.     IF filename="" THEN RETURN FALSE END;
  441.     IF TF.Open(file,filename,1024,TF.newFile) THEN
  442.       AVL.DoForward(root,SaveValue);
  443.       ok:=file.res=TF.done;
  444.       RETURN TF.Close(file) AND ok;
  445.     ELSE RETURN FALSE END;
  446.   END SaveValues;
  447.  
  448.   PROCEDURE * WriteValue(el:AVL.NodePtr);
  449.     CONST GS=14;
  450.     VAR
  451.       str:ARRAY 256 OF CHAR; (* 1 Line *)
  452.       s:ARRAY (GS+7) OF CHAR;
  453.       i:INTEGER;
  454.   BEGIN
  455.     IF el IS ValueNode THEN
  456.       WITH el:ValueNode DO
  457.         COPY(el.name,str);
  458.         i:=Strings.Length(str);
  459.         WHILE i<20 DO
  460.           str[i]:=Space;
  461.           INC(i);
  462.           str[i]:=0X;
  463.         END;
  464.         IF NOT LRC2.RealToString(values^[el.index],s,GS,GS,TRUE,TRUE)
  465.         THEN ImpErr END;
  466.         Strings.Append(str,' = ');
  467.         Strings.Append(str,s);
  468.         IF el.comment#'' THEN
  469.           Strings.Append(str,' ; ');
  470.           Strings.Append(str,el.comment);
  471.         END;
  472.       END;
  473.       writeProc(str);
  474.     END;
  475.   END WriteValue;
  476.  
  477.   PROCEDURE WriteValues*(p:WriteProc);
  478.   BEGIN
  479.     IF p#NIL THEN
  480.       writeProc:=p; (* I don't like this way, using a global       *)
  481.                     (* procedurevariable, but this is the only way *)
  482.       AVL.DoForward(root,WriteValue);
  483.     END;
  484.   END WriteValues;
  485.  
  486.   PROCEDURE * WriteFunction(el:AVL.NodePtr);
  487.   VAR
  488.     str:ARRAY 16 OF CHAR;
  489.   BEGIN
  490.     IF el IS FuncNode THEN
  491.       COPY(el(FuncNode).name,str);
  492.       Strings.Append(str,'()');
  493.       writeProc(str);
  494.     END;
  495.   END WriteFunction;
  496.  
  497.   PROCEDURE WriteFunctions*(p:WriteProc);
  498.   BEGIN
  499.     IF p#NIL THEN
  500.       writeProc:=p;
  501.       AVL.DoForward(root,WriteFunction);
  502.     END;
  503.   END WriteFunctions;
  504.  
  505.   PROCEDURE AddFunctionsToAVL;
  506.     VAR
  507.       i:INTEGER;
  508.       fnPtr:FuncNodePtr;
  509.   BEGIN
  510.     i:=0;
  511.     WHILE i<Functions DO
  512.       NEW(fnPtr);
  513.       Requests.Assert(fnPtr#NIL,OoM);
  514.       COPY(FunctionArray[i],fnPtr.name);
  515.       fnPtr.index:=FirstFunction+i;
  516.       IF NOT AVL.SAdd(root,fnPtr) THEN ImpErr END;
  517.       INC(i);
  518.     END;
  519.   END AddFunctionsToAVL;
  520.  
  521.   PROCEDURE RemoveValue*(name:ARRAY OF CHAR):BOOLEAN;
  522.   (* $CopyArrays- *)
  523.     VAR
  524.       el:AVL.NodePtr;
  525.       avlName:AVL.String;
  526.   BEGIN
  527.     COPY(name,avlName);
  528.     el:=AVL.SFind(root,avlName);
  529.     IF (el#NIL) THEN
  530.       IF (el IS ValueNode) THEN
  531.         values^[el(ValueNode).index]:=MAX(LONGREAL); (* NOT valid *)
  532.         IF AVL.Remove(root,el) THEN
  533.           DISPOSE(el);
  534.           RETURN TRUE
  535.         ELSE
  536.           RETURN FALSE
  537.         END;
  538.       ELSE
  539.         RETURN FALSE
  540.       END;
  541.     ELSE
  542.       RETURN FALSE
  543.     END;
  544.   END RemoveValue;
  545.  
  546.   PROCEDURE DisposeAllValues*;
  547.   BEGIN
  548.     AVL.Dispose(root);
  549.     ValueCounter:=0;
  550.     AddFunctionsToAVL;
  551.   END DisposeAllValues;
  552.  
  553.   PROCEDURE Compile*(str:ARRAY OF CHAR;VAR formula:Formula):BOOLEAN;
  554.   (* $CopyArrays- *)
  555.  
  556.     PROCEDURE Scan(str:ARRAY OF CHAR):BOOLEAN;
  557.     (* $CopyArrays- *)
  558.       VAR
  559.         strPos:INTEGER;
  560.         bufPos,fPos,constCount:INTEGER;
  561.         x:LONGREAL;
  562.         buf:AVL.String;
  563.         overflow:BOOLEAN; (* only TRUE if str contains nonsens *)
  564.  
  565.       PROCEDURE GetIt;
  566.       BEGIN
  567.         IF bufPos<(AVLStringSize-1) THEN
  568.           buf[bufPos]:=str[strPos];
  569.           INC(bufPos);
  570.           buf[bufPos]:=0X;
  571.         ELSE
  572.           overflow:=TRUE
  573.         END;
  574.         INC(strPos);
  575.       END GetIt;
  576.  
  577.       PROCEDURE Put(v:INTEGER);
  578.       BEGIN
  579.         IF fPos<FormulaSize THEN  (* ELSE overflow, we check it later *)
  580.           formula.el[fPos]:=v;
  581.           INC(fPos);
  582.         END;
  583.       END Put;
  584.  
  585.       PROCEDURE Find(name:AVL.String):BOOLEAN;
  586.       (* $CopyArrays- *)
  587.         VAR
  588.           snodePtr:AVL.SNodePtr;
  589.       BEGIN
  590.         snodePtr:=AVL.SFind(root,name);
  591.         IF snodePtr=NIL THEN RETURN FALSE END;
  592.         IF snodePtr IS FuncNode THEN
  593.           Put(snodePtr(FuncNode).index);
  594.         ELSIF snodePtr IS ValueNode THEN
  595.           Put(snodePtr(ValueNode).index)
  596.         ELSE
  597.           ImpErr
  598.         END;
  599.         RETURN TRUE
  600.       END Find;
  601.  
  602.       PROCEDURE ScanReal():BOOLEAN;
  603.       BEGIN
  604.         bufPos:=0;
  605.         WHILE (str[strPos]>='0') AND (str[strPos]<='9') DO GetIt END;
  606.         IF str[strPos]='.' THEN
  607.           GetIt;
  608.           WHILE (str[strPos]>='0') AND (str[strPos]<='9') DO GetIt END;
  609.         END;
  610.         IF str[strPos]='E' THEN
  611.           GetIt;
  612.           IF (str[strPos]='+') OR (str[strPos]='-') THEN GetIt END;
  613.           WHILE (str[strPos]>='0') AND (str[strPos]<='9') DO GetIt END;
  614.         END;
  615.         RETURN LRC2.StringToReal(buf,x);
  616.       END ScanReal;
  617.  
  618.       PROCEDURE ScanName;
  619.       BEGIN
  620.         bufPos:=0;
  621.         LOOP
  622.           CASE str[strPos] OF
  623.             0X,'(','[','{','}',']',')','+','-','*','/','^':
  624.             EXIT;
  625.           ELSE
  626.             GetIt;
  627.           END;
  628.         END;
  629.       END ScanName;
  630.  
  631.     BEGIN
  632.       overflow:=FALSE;
  633.       strPos:=0; fPos:=0;
  634.       constCount:=0;
  635.       LOOP
  636.         CASE str[strPos] OF
  637.            0X:EXIT|
  638.           '(','[','{':Put(Bra);INC(strPos)|
  639.           ')',']','}':Put(Ket);INC(strPos)|
  640.           '+':Put(Plus);INC(strPos)|
  641.           '-':Put(Minus);INC(strPos)|
  642.           '*':Put(Times);INC(strPos)|
  643.           '/':Put(Div);INC(strPos)|
  644.           '^':Put(Hi);INC(strPos)|
  645.           '0'..'9','.': IF NOT ScanReal() OR (constCount=Consts) THEN
  646.                           RETURN FALSE
  647.                         ELSE
  648.                           formula.const[constCount]:=x;
  649.                           Put(FirstConst+constCount);
  650.                           INC(constCount)
  651.                         END;
  652.         ELSE
  653.           ScanName;
  654.           IF NOT Find(buf) THEN RETURN FALSE END;
  655.         END
  656.       END;
  657.       Put(EOF);
  658.       RETURN (NOT overflow) AND (fPos<FormulaSize);
  659.     END Scan;
  660.  
  661.     PROCEDURE SyntaxOK(VAR f:Formula):BOOLEAN;
  662.       VAR
  663.         o,i:INTEGER;
  664.     BEGIN
  665.       o:=0;
  666.       i:=0;
  667.       CASE f.el[i] OF
  668.         FirstValue..LastFunction,Plus,Minus,Bra(*,EOF*):
  669.       ELSE RETURN FALSE END;
  670.       LOOP
  671.         INC(i);
  672.         CASE f.el[i-1] OF
  673.           EOF:EXIT|
  674.           FirstValue..LastConst:CASE f.el[i] OF Ket,Plus..Hi,EOF:
  675.                                 ELSE RETURN FALSE END|
  676.           FirstFunction..LastFunction:
  677.             CASE f.el[i] OF Bra: ELSE RETURN FALSE END|
  678.           Bra:INC(o);
  679.             CASE f.el[i] OF Ket,EOF,Times..Hi:RETURN FALSE ELSE END|
  680.           Ket:DEC(o);
  681.             CASE f.el[i] OF Plus..Hi,Ket,EOF: ELSE RETURN FALSE END|
  682.           Plus..Hi:CASE f.el[i] OF FirstValue..LastFunction,Bra:
  683.                              ELSE RETURN FALSE END;
  684.         ELSE RETURN FALSE END;
  685.       END;
  686.       RETURN o=0;
  687.     END SyntaxOK;
  688.  
  689.   BEGIN
  690.     IF Scan(str) AND SyntaxOK(formula) THEN
  691.       formula.error:=NoError;
  692.       RETURN TRUE;
  693.     ELSE
  694.       formula.error:=CompileError;
  695.       RETURN FALSE
  696.     END;
  697.   END Compile;
  698.  
  699.   PROCEDURE Evaluate*(VAR formula:Formula; VAR res:LONGREAL):BOOLEAN;
  700.  
  701.     VAR
  702.       pos:INTEGER;
  703.       op:INTEGER;
  704.  
  705.   PROCEDURE ^ Sum():LONGREAL;
  706.  
  707.   PROCEDURE Next():LONGREAL;
  708.   (* Returns current number and sets op to next operator *)
  709.   (* After a call of Next() formula.el[pos] is the next number *)
  710.     VAR x:LONGREAL;
  711.         c:INTEGER;
  712.         num:INTEGER;
  713.   BEGIN
  714.     CASE formula.el[pos] OF
  715.       FirstFunction..LastFunction:c:=formula.el[pos];INC(pos)
  716.     ELSE
  717.       c:=id;
  718.     END;
  719.     num:=formula.el[pos];
  720.     IF num=Bra THEN
  721.       INC(pos);
  722.       x:=Sum()
  723.     ELSIF num<=LastValue THEN
  724.       x:=values^[num];INC(pos);
  725.     ELSIF num<=LastConst THEN
  726.       x:=formula.const[num-FirstConst];INC(pos);
  727.     ELSE
  728.       ImpErr
  729.     END;
  730.     CASE formula.el[pos] OF
  731.       FirstOp..LastOp:op:=formula.el[pos]
  732.     ELSE
  733.       ImpErr
  734.     END;
  735.     INC(pos);
  736.     CASE c OF (* simpel and often used functions first *)
  737.       id:RETURN x|
  738.       jump:IF x>0 THEN RETURN 1 ELSE RETURN 0 END|
  739.       entier:IF ABS(x)>MAX(LONGINT) THEN formula.error:=entierError
  740.                                     ELSE RETURN ENTIER(x) END|
  741.       int:RETURN MATHLIB.INT(x)|
  742.       ceil:RETURN MathIEEEDoubBas.Ceil(x)|
  743.       floor:RETURN MathIEEEDoubBas.Floor(x)|
  744.       round:RETURN MathIEEEDoubBas.Floor(x+0.5D)|
  745.       abs:RETURN ABS(x)|
  746.       sqr:x:=MATHLIB.SQR(x)|
  747.       sqrt:IF x<0 THEN formula.error:=sqrtError
  748.                   ELSE RETURN MATHLIB.SQRT(x) END|
  749.       exp:x:=MATHLIB.ETOX(x)|
  750.       ln:IF x>0 THEN RETURN MATHLIB.LOGN(x)
  751.                 ELSE formula.error:=lnError END|
  752.       log,log10:IF x>0 THEN RETURN MATHLIB.LOG10(x)
  753.                        ELSE formula.error:=lnError END|
  754.       log2:IF x>0 THEN RETURN MATHLIB.LOG2(x)
  755.                   ELSE formula.error:=lnError END|
  756.       tentox:x:=MATHLIB.TENTOX(x)|
  757.       twotox:x:=MATHLIB.TWOTOX(x)|
  758.       sin:RETURN MATHLIB.SIN(x)|
  759.       arcsin:IF ABS(x)>1 THEN formula.error:=arcsinError
  760.                          ELSE RETURN MATHLIB.ASIN(x) END|
  761.       cos:RETURN MATHLIB.COS(x)|
  762.       arccos:IF ABS(x)>1 THEN formula.error:=arccosError
  763.                          ELSE RETURN MATHLIB.ACOS(x) END|
  764.       tan:x:=MATHLIB.TAN(x)|
  765.       arctan:RETURN MATHLIB.ATAN(x)|
  766.       sinh:RETURN MATHLIB.SINH(x)|
  767.       cosh:RETURN MATHLIB.COSH(x)|
  768.       tanh:RETURN MATHLIB.TANH(x)|
  769.       artanh:IF ABS(x)<1 THEN RETURN MATHLIB.ATANH(x)
  770.                          ELSE formula.error:=artanhError END|
  771.       DegToRad:RETURN x*(Pi/180)|
  772.       RadToDeg: x:=x*(180/Pi)|
  773.       RND: IF RN(x) THEN RETURN x ELSE formula.error:=rndError END|
  774.       fac: IF FAC(x) THEN RETURN x ELSE formula.error:=facError END|
  775.     END;
  776.     IF ABS(x)=MAX(LONGREAL) THEN formula.error:=Overflow END;
  777.     RETURN x;
  778.   END Next;
  779.  
  780.   PROCEDURE Pot():LONGREAL;
  781.   (* I don't trust MathIEEEDoubTrans.Pow(exp,base).
  782.      There can be problems if base is negative. Under OS2.0 it may
  783.      work, but what is under KS1.2, 1.3 or 2.x. So I use LOGN(x).
  784.      This should be safe if x is greater than zero.
  785.      (base^exp=Pow(exp,base)=ETOX(exp*LOGN(base))
  786.   *)
  787.     VAR
  788.       base:LONGREAL;
  789.       exp:LONGREAL;
  790.       l:LONGINT;
  791.   BEGIN
  792.     base:=Next();
  793.     LOOP
  794.       CASE op OF
  795.         Hi:exp:=Next();
  796.            IF (base>0) THEN (* no problem *)
  797.              base:=MATHLIB.ETOX(exp*MATHLIB.LOGN(base))
  798.            ELSIF base=0 THEN (*base:=0*)
  799.            ELSIF ABS(exp)<MAX(LONGINT) THEN
  800.              l:=ENTIER(exp);
  801.              IF l=exp THEN
  802.                base:=MATHLIB.ETOX(exp*MATHLIB.LOGN(ABS(base)));
  803.                IF ODD(l) THEN base:=-base END
  804.              ELSE
  805.                formula.error:=powError
  806.              END
  807.            ELSE
  808.              formula.error:=powError
  809.            END|
  810.         Plus,Minus,Ket,EOF,Times,Div:EXIT
  811.         (*Operators for Prod() or Sum() *)
  812.       ELSE
  813.         ImpErr
  814.       END;
  815.       IF ABS(base)=MAX(LONGREAL) THEN formula.error:=Overflow END;
  816.     END;
  817.     RETURN base
  818.   END Pot;
  819.  
  820.   PROCEDURE Prod():LONGREAL;
  821.     VAR
  822.       prod:LONGREAL;
  823.       h:LONGREAL;
  824.   BEGIN
  825.     prod:=Pot();
  826.     LOOP
  827.       CASE op OF
  828.         Times:prod:=prod*Pot()|
  829.         Div:h:=Pot();
  830.           IF h#0 THEN prod:=prod/h ELSE formula.error:=DivisionByZero END|
  831.         Plus,Minus,Ket,EOF:EXIT (* operators for Sum() *)
  832.       ELSE
  833.         ImpErr
  834.       END;
  835.       IF ABS(prod)=MAX(LONGREAL) THEN formula.error:=Overflow END;
  836.     END;
  837.     RETURN prod
  838.   END Prod;
  839.  
  840.   PROCEDURE Sum():LONGREAL;
  841.   (* Every "(" calls Sum(), so turn on StachCheck here! *)
  842.   (* $StackChk+ *)
  843.     VAR
  844.       sum:LONGREAL;
  845.   BEGIN
  846.     sum:=0;
  847.     op:=formula.el[pos];
  848.     CASE op OF
  849.       EOF:|
  850.       Plus,Minus:INC(pos)
  851.     ELSE
  852.       op:=Plus
  853.     END;
  854.     LOOP
  855.       CASE op OF
  856.         Plus:sum:=sum+Prod()|
  857.         Minus:sum:=sum-Prod()|
  858.         Ket,EOF:EXIT
  859.       ELSE
  860.         ImpErr
  861.       END;
  862.       IF ABS(sum)=MAX(LONGREAL) THEN formula.error:=Overflow END;
  863.     END;
  864.     RETURN sum;
  865.     (* $StackChk= *)
  866.   END Sum;
  867.  
  868.   BEGIN
  869.     pos:=0;
  870.     formula.error:=NoError;
  871.     res:=Sum();
  872.     RETURN formula.error=NoError;
  873.   END Evaluate;
  874.  
  875. BEGIN
  876.   OberonLib.StackChk(MinStack);
  877.   (* IF our stack is too small then abort.   *)
  878.   (* This Check is no guarantee that we have *)
  879.   (* enougth stack all the time.             *)
  880.   NEW(values);
  881.   Requests.Assert(values#NIL,OoM);
  882.   ValueCounter:=0;
  883.   InitFac;
  884.   AVL.SInit(root);
  885.   AddFunctionsToAVL;
  886. END Formula.
  887.  
  888.